perm filename SPACE4.F4[JC,MUS] blob sn#007310 filedate 1972-07-16 generic text, type T, neo UTF8
00100		SUBROUTINE SPACE4(AMP,RAMP,DOP,CHNA,CHNB,CHNC,CHND,ARRAY)
00200		DIMENSION AMP(512),RAMP(512),DOP(512),
00300		1 CHNA(512),CHNB(512),CHNC(512),CHND(512)
00400		DIMENSION F(7),G(3)
00500	     	DIMENSION ARRAY(2,600),B(4),C(7),D(4),E(7)
00600		DIMENSION ST(50),SU(350)
00700		DATA (B(I),I=1,3)/'A TO B IN FT.'/
00800		DATA (C(I),I=1,3)/'CIRC=1,LINE=2'/
00900		DATA (D(I),I=1,3)/'0=FIN,1=REDEF'/
01000		DATA (E(I),I=1,6)/'SEE AMP=1,DOP=2,STER1=3 OR 0'/
01100		DATA (F(I),I=1,5)/'X,Y,RAD OR X1,Y1,X2,Y2'/
01200		DATA (G(I),I=1,2)/'CYCL TM='/
01300		CALL TYPLOC(-300,-512)
01400	101	CONTINUE
01500		CALL DPYSET(1,ST,50)
01600		CALL DPYBRT(1)
01700		CALL AIVECT(0,0)
01800		CALL HYDPOG(1)
01900		IF(KT1.EQ.1)KT1=513
02000		IY=100
02100		DO 11 I=1,2
02200		CALL ALINE(-100,IY,100,IY)
02300	11	IY=-IY
02400		IX=100
02500		DO 12 I=1,2
02600		CALL ALINE(IX,-100,IX,100)
02700	12	IX=-IX
02800		CALL ALINE(0,0,0,100)
02900		CALL DPYOUT(1)
03000	CC  SPACE DEFINITION FINISHED
03100		CALL MESS(B)
03200		CALL RDNUM(DIS)
03300		DELTA=DIS/100.0
03400		CALL MESS(C)
03500		CALL RDNUM(XNUM)
03600		IF(XNUM.EQ.0.0)GO TO 20
03700		L=XNUM
03800		CALL DPYSET(2,SU,350)
03900		CALL DPYBRT(6)
04000		CALL AIVECT(0,0)
04100		CALL MESS(F)
04200		GO TO (1,2,2),L
04300	1	CALL RDNUM(XCO)
04400		CALL RDNUM(YCO)
04500		CALL RDNUM(RADIUS)
04600		RADNS=(2.0*3.1415927)/512.0
04700		CRADNS=RADNS
04800		IL=1
04900	36	CONTINUE
05000		SINR=SIN(CRADNS)
05100		COSR=COS(CRADNS)
05200		CRADNS=CRADNS+RADNS
05300		ARRAY(1,IL)=SINR*RADIUS+XCO
05400		ARRAY(2,IL)=COSR*RADIUS+YCO
05500		GO TO 520
05600	2	CALL RDNUM(XCO1)
05700		CALL RDNUM(YCO1)
05800		CALL RDNUM(XCO2)
05900	      	CALL RDNUM(YCO2)
06000		IF(L.EQ.3)GOTO 3
06100		XCOI=(XCO2-XCO1)/512.0
06200	        YCOI=(YCO2-YCO1)/512.0
06300		XCO1=XCO1-XCOI
06400	        YCO1=YCO1-YCOI
06500		IL=1
06600	37	CONTINUE
06700		ARRAY(1,IL)=XCO1+XCOI
06800		ARRAY(2,IL)=YCO1+YCOI
06900		XCO1=XCO1+XCOI
07000		YCO1=YCO1+YCOI
07100		GO TO 520
07200	3	CALL RDNUM(XCO3)
07300		CALL RDNUM(YCO3)
07400		XDIF1=XCO2-XCO1
07500		XDIF2=XCO3-XCO2
07600		YDIF1=YCO2-YCO1
07700		YDIF2=YCO3-YCO2
07710		XCO4=XCO2+XDIF2-XDIF1
07720		YCO4=YCO2+YDIF2-YDIF1	
07800		XCOI1=XDIF1/128.
07900		XCOI2=XDIF2/128.
08000		YCOI1=YDIF1/128.
08100		YCOI2=YDIF2/128.
08200	C	XCO1=XCO1-XCOI1
08300	C	YCO1=YCO1-YCOI1
08400		IL=1
08500	32	IF(IL.GT.128)GO TO 33
08600		ARRAY(1,IL)=XCO1+XCOI1
08700		ARRAY(2,IL)=YCO1+YCOI1
08800		XCO1=ARRAY(1,IL)
08900		YCO1=ARRAY(2,IL)
09000		GO TO 520
09100	33	IF(IL.GT.256.)GO TO 34
09200		ARRAY(1,IL)=XCO2+XCOI2
09300		ARRAY(2,IL)=YCO2+YCOI2
09400		XCO2=ARRAY(1,IL)
09500		YCO2=ARRAY(2,IL)
09600		GO TO 520
09700	34	IF(IL.GT.384)GO TO 35
09800		ARRAY(1,IL)=XCO3-XCOI1
09900		ARRAY(2,IL)=YCO3-YCOI1
10000		XCO3=ARRAY(1,IL)
10100		YCO3=ARRAY(2,IL)
10200		GO TO 520
10300	35	ARRAY(1,IL)=XCO4-XCOI2
10400	        ARRAY(2,IL)=YCO4-YCOI2
10500		XCO4=ARRAY(1,IL)
10600		YCO4=ARRAY(2,IL)
10700	520	NEWX=ARRAY(1,IL)
10800		NEWY=ARRAY(2,IL)
10900		IF(IL.GT.1)GO TO 503
11000		CALL AIVECT(NEWX,NEWY)
11100		GO TO 504
11200	503	CALL SVECT(NEWX-IOLDX,NEWY-IOLDY)
11300	504	IOLDX=NEWX
11400		IOLDY=NEWY
11500		CALL DPYOUT(2)
11600		IL=IL+1
11700		IF(IL.GT.512)GO TO 500
11800		GO TO (36,37,32),L
11900	500	CONTINUE
12000		M=512
12100		CALL MESS(G)
12200		CALL RDNUM(SPD1)
12300		SPD1=60.0/((1.0/SPD1)*512.0)
12400		GO TO 501
12500	20	CONTINUE
12600	C	CALL POS(ARRAY,600,M,SPD1)
12700	501	X=M-1
12800		AI=X/512.0
12900		BI=2.0
13000		S=60.0/SPD1
13100		R=SQRT(ARRAY(1,1)**2+ARRAY(2,1)**2)
13200		DO 100 J=1,512
13300		I=BI
13400		X=ARRAY(1,I)
13500		Y=ARRAY(2,I)
13600		BI=BI+AI
13700		R1=SQRT(X**2+Y**2)
13800		AMP(J)=DIS/(R1*DELTA)
13900		RAMP(J)=ALOG(DIS)/ALOG(R1*DELTA)
14000		CONTINUE
14100		VR=S*DELTA*(R1-R)
14200		XJ=J
14300		IF((R1.EQ.R).AND.(XJ.GT.1.0))GO TO 31
14400		DOP(J)=1180.0/(1180.0+VR)
14500		GO TO 21
14600	31	DOP(J)=DOP(J-1)
14700	21	R=R1
14800		CONTINUE
14900		AX=ABS(X)
15000		AY=ABS(Y)
15010		PI=3.1416
15020		ANGLE=AMOD(ATAN2(Y,X)+6.2832,6.2832)	
15025		PI2=PI/2.0
15100		IF((AX.LE.AY).AND.(Y.GT.0.0))GO TO 2000
15200		IF((AX.GT.AY).AND.(X.GT.0.0))GO TO 2001
15300		IF((AX.LE.AY).AND.(Y.LT.0.0))GO TO 2002
15400		CHN=ANGLE-(3.*PI)/4.	
15500		CHNB(J)=1.-CHN/PI2	
15600		CHNC(J)=CHN/PI2	
15700		CHNA(J)=0.0
15800		CHND(J)=0.0
15900		GO TO 100	
16000	2000	CHN=ANGLE-PI/4.
16100		CHNA(J)=1.-CHN/PI2	
16200		CHNB(J)=CHN/PI2	
16300		CHNC(J)=0.0
16400		CHND(J)=0.0
16500		GO TO 100	
16600	2001	CHN=ANGLE-(7.*PI)/4.	
16650		IF(ANGLE.LT.PI/4.)CHN=ANGLE+PI/4.
16700		CHND(J)=1.-CHN/PI2	
16800		CHNA(J)=CHN/PI2	
16900		CHNB(J)=0.0
17000		CHNC(J)=0.0
17100		GO TO 100	
17200	2002	CHN=ANGLE-(5.*PI)/4.	
17300		CHNC(J)=1.-CHN/PI2	
17400		CHND(J)=CHN/PI2	
17500		CHNA(J)=0.0
17600		CHNB(J)=0.0
17700	100	CONTINUE
17705		DO 402 JK=1,512
17710		CHNA(JK)=SQRT(CHNA(JK))
17715		CHNB(JK)=SQRT(CHNB(JK))
17720		CHNC(JK)=SQRT(CHNC(JK))
17725		CHND(JK)=SQRT(CHND(JK))
17730	402	CONTINUE
17800		CALL INTERP(AMP)
17900		CALL INTERP(RAMP)
18000		CALL INTERP(DOP)
18100	C	CALL INTERP(CHNA)
18200	C	CALL INTERP(CHNB)
18300	C	CALL INTERP(CHNC)
18400	C	CALL INTERP(CHND)
18500	801	CONTINUE
18600		GO TO 937
18700	99	CONTINUE
18800	937	CALL MESS(E)
18900		CALL RDNUM(X)
19000		L=X
19100		IF(L.EQ.0)GO TO 200
19200		IF(L.GT.3)GO TO 937
19300		CALL HYDPOG(1)
19400		CALL HYDPOG(2)
19500		CONTINUE
19600		CALL DPYSET(1,ST,50)
19700		CALL DPYBRT(1)
19800		CALL AIVECT(0,0)
19900		IF(L.EQ.3)GO TO 203
20000		CALL ALINE(-264,0,256,0)
20100		CALL ALINE(-256,-256,-256,256)
20200		CALL DPYOUT(1)
20300		CALL DPYSET(2,SU,350)
20400		CALL DPYBRT(6)
20500		CALL AIVECT(0,0)
20600		GO TO(201,202),L
20700	201	IY=AMP(1)*256.
20800		CALL AIVECT(-256,IY)
20900		DO 301 I=2,512
21000		IY2=AMP(I)*256.0
21100		CALL SVECT(1,IY2-IY)
21200		IY=IY2
21300	301	CALL DPYOUT(2)
21400		GO TO 99
21500	202	IY=DOP(1)*256.-256.
21600		CALL AIVECT(-256,IY)
21700		DO 302 I=2,512
21800		IY2=DOP(I)*256.0-256.
21900		CALL SVECT(1,IY2-IY)
22000		IY=IY2
22100	302	CALL DPYOUT(2)
22200		GO TO 99
22300	203	CONTINUE
22400		DO 300 J=-375,375,250
22500		CALL AIVECT(0,J)
22600		CALL RVECT(256,0)
22700		CALL RIVECT(-256,-125)
22800		CALL RVECT(0,250)
22900	300	CALL DPYOUT(1)
23000		CALL DPYSET(2,SU,350)
23100		CALL DPYBRT(6)
23200		CALL AIVECT(0,0)
23300		IY=375
23400		CALL DRAW(CHNA,IY)
23500		IY=125
23600		CALL DRAW(CHNB,IY)
23700		IY=-125
23800		CALL DRAW(CHNC,IY)
23900		IY=-375
24000		CALL DRAW(CHND,IY)
24100		GO TO 99
24200	200	CALL MESS(D)
24300		CALL RDNUM(X)
24400		IF(X.EQ.0.0)GO TO 307
24500		CALL HYDPOG(2)
24600		GO TO 101
24700	307	CONTINUE
24800		CALL DPYCLR
24900		RETURN
25000		END
25100	CC******WAVE DRAWER**********************************************
25200		SUBROUTINE DRAW(FUNC,ICT)
25300		DIMENSION FUNC(512)
25400		CALL AIVECT(0,ICT)
25500		DO 100 I=1,512,4
25600		IY2=FUNC(I)*125.
25700		IF(I.GT.1)GO TO 10
25800		CALL RIVECT(0,IY2)
25900		GO TO 101
26000	10	CALL SVECT(2,IY2-IY)
26100	101	IY=IY2
26200	100	CALL DPYOUT(2)
26300		RETURN
26400		END
26500	CC******WAVE SMOOTHER********************************************
26600		SUBROUTINE INTERP(CFUNC)
26700		DIMENSION CFUNC(512)
26800		JT=0
26900		DO 601 KT=2,512
27000		IF(CFUNC(KT-1).NE.CFUNC(KT))GO TO 600
27100		IF(JT.EQ.0)JT=KT-1
27200		GO TO 601
27300	600	IF(JT.EQ.0)GO TO 601
27400		DIFF=CFUNC(KT)-CFUNC(JT)
27500		DIV=KT-JT
27600		ANS=DIFF/DIV
27700		DO 602 LM=JT+1,KT-1
27800	602	CFUNC(LM)=CFUNC(LM-1)+ANS
27900		JT=0
28000	601	CONTINUE
28100		RETURN
28200		END